{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

-- For @instance AuthDB Spar@

-- | > docs/reference/provisioning/scim-token.md {#RefScimToken}
--
-- Logic for doing authentication in SCIM routes.
--
-- Every time a request to SCIM API is done, we grab a 'ScimToken' from the @"Authorization"@
-- header, check that it's valid, and resolve the team that this operation should apply to.
module Spar.Scim.Auth
  ( apiScimToken,
  )
where

import Control.Lens hiding (Strict, (.=))
import qualified Data.ByteString.Base64 as ES
import Data.Code as Code
import Data.Id
import Data.Misc
import qualified Data.Text.Encoding as T
import Data.Text.Encoding.Error
import Imports
import Polysemy
import Polysemy.Error
import Polysemy.Input
import qualified SAML2.WebSSO as SAML
import Servant (NoContent (NoContent), ServerT, (:<|>) ((:<|>)))
import Spar.App (throwSparSem)
import qualified Spar.Error as E
import qualified Spar.Intra.BrigApp as Intra.Brig
import Spar.Options
import Spar.Sem.BrigAccess (BrigAccess)
import qualified Spar.Sem.BrigAccess as BrigAccess
import Spar.Sem.GalleyAccess (GalleyAccess)
import Spar.Sem.IdPConfigStore (IdPConfigStore)
import qualified Spar.Sem.IdPConfigStore as IdPConfigStore
import Spar.Sem.ScimTokenStore (ScimTokenStore)
import qualified Spar.Sem.ScimTokenStore as ScimTokenStore
import qualified Web.Scim.Class.Auth as Scim.Class.Auth
import qualified Web.Scim.Handler as Scim
import qualified Web.Scim.Schema.Error as Scim
import Wire.API.Routes.Named
import Wire.API.Routes.Public.Spar (APIScimToken)
import Wire.API.User as User
import Wire.API.User.Scim as Api
import Wire.Sem.Now (Now)
import qualified Wire.Sem.Now as Now
import Wire.Sem.Random (Random)
import qualified Wire.Sem.Random as Random

-- | An instance that tells @hscim@ how authentication should be done for SCIM routes.
instance (Member ScimTokenStore r) => Scim.Class.Auth.AuthDB SparTag (Sem r) where
  -- Validate and resolve a given token
  authCheck :: Maybe ScimToken -> Scim.ScimHandler (Sem r) ScimTokenInfo
  authCheck Nothing =
    Scim.throwScim (Scim.unauthorized "Token not provided")
  authCheck (Just token) =
    maybe (Scim.throwScim (Scim.unauthorized "Invalid SCIM token")) pure
      =<< lift (ScimTokenStore.lookup token)

----------------------------------------------------------------------------
-- Token API

-- TODO: don't forget to delete the tokens when the team is deleted

-- | API for manipulating SCIM tokens (protected by normal Wire authentication and available
-- only to team owners).
apiScimToken ::
  ( Member Random r,
    Member (Input Opts) r,
    Member GalleyAccess r,
    Member BrigAccess r,
    Member ScimTokenStore r,
    Member Now r,
    Member IdPConfigStore r,
    Member (Error E.SparError) r
  ) =>
  ServerT APIScimToken (Sem r)
apiScimToken =
  Named @"auth-tokens-create@v7" createScimTokenV7
    :<|> Named @"auth-tokens-create" createScimToken
    :<|> Named @"auth-tokens-put-name" updateScimTokenName
    :<|> Named @"auth-tokens-delete" deleteScimToken
    :<|> Named @"auth-tokens-list@v7" listScimTokensV7
    :<|> Named @"auth-tokens-list" listScimTokens

updateScimTokenName ::
  ( Member BrigAccess r,
    Member ScimTokenStore r,
    Member (Error E.SparError) r,
    Member GalleyAccess r
  ) =>
  UserId ->
  ScimTokenId ->
  ScimTokenName ->
  Sem r ()
updateScimTokenName lusr tokenId name = do
  teamid <- Intra.Brig.authorizeScimTokenManagement (Just lusr)
  ScimTokenStore.updateName teamid tokenId name.fromScimTokenName

-- | > docs/reference/provisioning/scim-token.md {#RefScimTokenCreate}
--
-- Create a token for user's team.
createScimTokenV7 ::
  forall r.
  ( Member Random r,
    Member (Input Opts) r,
    Member GalleyAccess r,
    Member BrigAccess r,
    Member ScimTokenStore r,
    Member IdPConfigStore r,
    Member Now r,
    Member (Error E.SparError) r
  ) =>
  -- | Who is trying to create a token
  Maybe UserId ->
  -- | Request body
  CreateScimToken ->
  Sem r CreateScimTokenResponseV7
createScimTokenV7 zusr createTok = do
  teamid <- guardScimTokenCreation zusr createTok.password createTok.verificationCode
  idps <- IdPConfigStore.getConfigsByTeam teamid
  mIdpId <- case idps of
    [config] -> pure . Just $ config ^. SAML.idpId
    [] -> pure Nothing
    -- NB: if we ever were to allow several idps for one scim peer (which we won't),
    -- 'validateScimUser' would need to be changed.  currently, it relies on the association
    -- map from scim to saml being n:1.
    (_ : _ : _) -> throwSparSem $ E.SparProvisioningMoreThanOneIdP E.TwoIdpsAndScimTokenForbidden

  responseToV7 <$> createScimTokenUnchecked teamid Nothing createTok.description mIdpId
  where
    responseToV7 :: CreateScimTokenResponse -> CreateScimTokenResponseV7
    responseToV7 (CreateScimTokenResponse token info) = CreateScimTokenResponseV7 token (infoToV7 info)

    infoToV7 :: ScimTokenInfo -> ScimTokenInfoV7
    infoToV7 ScimTokenInfo {..} = ScimTokenInfoV7 {..}

-- | Create a token for the user's team.
--
-- > docs/reference/provisioning/scim-token.md {#RefScimTokenCreate}
-- > (on associating scim peers with idps) https://docs.wire.com/understand/single-sign-on/understand/main.html#associating-scim-tokens-with-saml-idps-for-authentication
createScimToken ::
  forall r.
  ( Member Random r,
    Member (Input Opts) r,
    Member GalleyAccess r,
    Member BrigAccess r,
    Member ScimTokenStore r,
    Member IdPConfigStore r,
    Member Now r,
    Member (Error E.SparError) r
  ) =>
  -- | Who is trying to create a token
  Maybe UserId ->
  -- | Request body
  CreateScimToken ->
  Sem r CreateScimTokenResponse
createScimToken zusr Api.CreateScimToken {..} = do
  teamid <- guardScimTokenCreation zusr password verificationCode
  mIdPId <- maybe (pure Nothing) (\idpid -> IdPConfigStore.getConfig idpid $> Just idpid) idp
  createScimTokenUnchecked teamid name description mIdPId

guardScimTokenCreation ::
  forall r.
  ( Member (Input Opts) r,
    Member GalleyAccess r,
    Member BrigAccess r,
    Member ScimTokenStore r,
    Member (Error E.SparError) r
  ) =>
  -- | Who is trying to create a token
  Maybe UserId ->
  Maybe PlainTextPassword6 ->
  Maybe Code.Value ->
  Sem r TeamId
guardScimTokenCreation zusr password verificationCode = do
  teamid <- Intra.Brig.authorizeScimTokenManagement zusr
  BrigAccess.ensureReAuthorised zusr password verificationCode (Just User.CreateScimToken)
  tokenNumber <- length <$> ScimTokenStore.lookupByTeam teamid
  maxTokens <- inputs maxScimTokens
  unless (tokenNumber < maxTokens) $
    throwSparSem E.SparProvisioningTokenLimitReached
  pure teamid

-- Create a token for user's team.
createScimTokenUnchecked ::
  forall r.
  ( Member Random r,
    Member ScimTokenStore r,
    Member Now r
  ) =>
  TeamId ->
  Maybe Text ->
  Text ->
  Maybe SAML.IdPId ->
  Sem r CreateScimTokenResponse
createScimTokenUnchecked teamid mName desc mIdPId = do
  token <-
    ScimToken . T.decodeUtf8With lenientDecode . ES.encode
      <$> Random.bytes 32
  tokenid <- Random.scimTokenId
  now <- Now.get
  let info =
        ScimTokenInfo
          { stiId = tokenid,
            stiTeam = teamid,
            stiCreatedAt = now,
            stiIdP = mIdPId,
            stiDescr = desc,
            stiName = fromMaybe (idToText tokenid) mName
          }
  ScimTokenStore.insert token info
  pure $ CreateScimTokenResponse token info

-- | > docs/reference/provisioning/scim-token.md {#RefScimTokenDelete}
--
-- Delete a token belonging to user's team.
deleteScimToken ::
  ( Member GalleyAccess r,
    Member BrigAccess r,
    Member ScimTokenStore r,
    Member (Error E.SparError) r
  ) =>
  -- | Who is trying to delete a token
  Maybe UserId ->
  ScimTokenId ->
  Sem r NoContent
deleteScimToken zusr tokenid = do
  teamid <- Intra.Brig.authorizeScimTokenManagement zusr
  ScimTokenStore.delete teamid tokenid
  pure NoContent

listScimTokensV7 ::
  ( Member GalleyAccess r,
    Member BrigAccess r,
    Member ScimTokenStore r,
    Member (Error E.SparError) r
  ) =>
  -- | Who is trying to list tokens
  Maybe UserId ->
  Sem r ScimTokenListV7
listScimTokensV7 zusr = toV7 <$> listScimTokens zusr
  where
    toV7 :: ScimTokenList -> ScimTokenListV7
    toV7 (ScimTokenList tokens) = ScimTokenListV7 $ map infoToV7 tokens

    infoToV7 :: ScimTokenInfo -> ScimTokenInfoV7
    infoToV7 ScimTokenInfo {..} = ScimTokenInfoV7 {..}

-- | > docs/reference/provisioning/scim-token.md {#RefScimTokenList}
--
-- List all tokens belonging to user's team. Tokens themselves are not available, only
-- metadata about them.
listScimTokens ::
  ( Member GalleyAccess r,
    Member BrigAccess r,
    Member ScimTokenStore r,
    Member (Error E.SparError) r
  ) =>
  -- | Who is trying to list tokens
  Maybe UserId ->
  Sem r ScimTokenList
listScimTokens zusr = do
  teamid <- Intra.Brig.authorizeScimTokenManagement zusr
  ScimTokenList <$> ScimTokenStore.lookupByTeam teamid
